home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / totsrc11.zip / TOTMISC.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-04  |  16KB  |  624 lines
  1. {               Copyright 1991 TechnoJock Software, Inc.               }
  2. {                          All Rights Reserved                         }
  3. {                         Restricted by License                        }
  4.  
  5. {                             Build # 1.10                             }
  6.  
  7. Unit totMISC;
  8. {$I TOTFLAGS.INC}
  9.  
  10. {
  11.  Development Notes: 1.00a  May 28 91  Added MiscInit to Interface
  12.                     1.00b  Jul 10 91  Added directory check in ValidFilename
  13.                     1.00c  Oct 9  91  Corrected FSize
  14.                     1.00d  Nov 6  91  Improved ValidFilename
  15.                     1.10   Dec 15 92  DPMI Update - changed ResetPrinter
  16. }
  17.  
  18. INTERFACE
  19.  
  20. Uses DOS, CRT, totSTR, totFAST;
  21.  
  22. var
  23.   LPTport:byte;     {0=lpt1, 1=lpt2, 2=lpt3}
  24.  
  25. procedure Swap(var A,B:longint);
  26. function  WithinRange(Min,Max,Test: longint): boolean;
  27. function  Exist(Filename:string):boolean;
  28. function  CopyFile(SourceFile, TargetFile:string): shortint;
  29. function  DeleteFile(Filename:string): shortint;
  30. function  RenameFile(Oldname,NewName:string):shortint;
  31. function  FSize(Filename:string): longint;
  32. function  FileDrive(Full:string): string;
  33. function  FileDirectory(Full:string): string;
  34. function  FileName(Full:string): string;
  35. function  FileExt(Full:string): string;
  36. function  SlashedDirectory(Dir:string):string;
  37. function  PrinterStatus:byte;
  38. function  AlternatePrinterStatus:byte;
  39. function  PrinterReady :boolean;
  40. procedure ResetPrinter;
  41. procedure PrintScreen;
  42. procedure Beep;
  43. function  CurrentTime: string;
  44. function  ParamLine: String;
  45. function  ParamVal(Marker:string): string;
  46. function  Frequency(Match:string;Source:string): byte;
  47. function  ValidFileName(FN:string): shortint;
  48. procedure ResetStartUpMode;
  49. function  RunAnything(Command: string):integer;
  50. function  RunEXECOM(Progname, Params: string):integer;
  51. function  RunDOS(Msg:string):integer;
  52. procedure MiscInit;
  53.  
  54. IMPLEMENTATION
  55. VAR
  56.     StartTop,      {used to record initial screen state when program is run}
  57.     StartBot   : Byte;
  58.     StartMode  : word;
  59.  
  60. procedure Swap(var A,B:longint);
  61. {}
  62. var Temp: longint;
  63. begin
  64.    Temp := A;
  65.    A := B;
  66.    B := Temp;
  67. end; {Swap}
  68.  
  69. function WithinRange(Min,Max,Test: longint): boolean;
  70. {}
  71. begin
  72.    if Min > Max then
  73.       Swap(Min,Max);
  74.    WithinRange := (Test >= Min) and (Test <= Max);
  75. end; {WithinRange}
  76.  
  77. function Exist(Filename:string):boolean;
  78. {returns true if file exists}
  79. var Inf: SearchRec;
  80. begin
  81.     findfirst(Filename,AnyFile,Inf);
  82.     Exist := (DOSError = 0);
  83. end;  {func Exist}
  84.  
  85. function CopyFile(SourceFile, TargetFile:string): shortint;
  86. {return codes:  0 successful
  87.                 1 source and target the same
  88.                 2 cannot open source
  89.                 3 unable to create target
  90.                 4 error during copy
  91. }
  92. var
  93.   Source,
  94.   Target: file;
  95.   BRead,
  96.   Bwrite: word;
  97.   FileBuf: array[1..2048] of char;
  98. begin
  99.    if SourceFile = TargetFile then
  100.       CopyFile := 1
  101.    else
  102.    begin
  103.       assign(Source,SourceFile);
  104.       {$I-}
  105.       reset(Source,1);
  106.       {$I+}
  107.       if IOResult <> 0 then
  108.           CopyFile := 2
  109.       else
  110.       begin
  111.          Assign(Target,TargetFile);
  112.          {$I-}
  113.          Rewrite(Target,1);
  114.          {$I+}
  115.          if IOResult <> 0 then
  116.             CopyFile := 3
  117.          else
  118.          begin
  119.             repeat
  120.               blockread(Source,FileBuf,SizeOf(FileBuf),BRead);
  121.               blockwrite(Target,FileBuf,Bread,Bwrite);
  122.             until (Bread = 0) or (Bread <> BWrite);
  123.             close(Source);
  124.             close(Target);
  125.             if Bread <> Bwrite then
  126.                CopyFile := 4
  127.             else
  128.                CopyFile := 0;
  129.          end;
  130.       end;
  131.    end;
  132. end; {CopyFile}
  133.  
  134. function FSize(Filename:string): longint;                 {1.00c}
  135. {returns  -1   if file not found}
  136. var FileInfo: SearchRec;
  137. begin
  138.    Findfirst(Filename,anyfile,FileInfo);
  139.    if DOSError = 0 then
  140.       FSize := FileInfo.Size
  141.    else
  142.       FSize := -1;
  143. end; {FSize}
  144.  
  145. function FileSplit(Part:byte;Full:string): string;
  146. {used internally}
  147. var
  148.    D : DirStr;
  149.    N : NameStr;
  150.    E : ExtStr;
  151. begin
  152.    FSplit(Full,D,N,E);
  153.    Case Part of
  154.    1 : FileSplit := D;
  155.    2 : FileSplit := N;
  156.    3 : FileSplit := E;
  157.    end;
  158. end; {FileSplit}
  159.  
  160. function FileDrive(Full:string): string;
  161. {}
  162. var
  163.   Temp : string;
  164.   P : byte;
  165. begin
  166.    Temp := FileSplit(1,Full);
  167.    P := Pos(':',Temp);
  168.    if P <> 2 then
  169.       FileDrive := ''
  170.    else
  171.       FileDrive := upcase(Temp[1]);
  172. end; {FileDrive}
  173.  
  174. function FileDirectory(Full:string): string;
  175. {}
  176. var
  177.   Temp : string;
  178.   P : byte;
  179. begin
  180.    Temp := FileSplit(1,Full);
  181.    P := Pos(':',Temp);
  182.    if P = 2 then
  183.       Delete(Temp,1,2);                 {remove drive}
  184.    if (Temp[length(Temp)]  ='\') and (temp <> '\') then
  185.       Delete(temp,length(Temp),1);      {remove last backslash}
  186.    FileDirectory := Temp;
  187. end; {FileDirectory}
  188.  
  189. function FileName(Full:string): string;
  190. {}
  191. begin
  192.    FileName := FileSplit(2,Full);
  193. end; {FileName}
  194.  
  195. function FileExt(Full:string): string;
  196. {}
  197. var
  198.   Temp : string;
  199. begin
  200.    Temp := FileSplit(3,Full);
  201.    if (Temp = '') or (Temp = '.') then
  202.       FileExt := temp
  203.    else
  204.       FileExt := copy(Temp,2,3);
  205. end; {FileExt}
  206.  
  207. function SlashedDirectory(Dir:string):string;
  208. {}
  209. begin
  210.    if (Dir = '') or (Dir[length(Dir)] in [':','\']) then
  211.       SlashedDirectory := Dir
  212.    else
  213.       SlashedDirectory := Dir + '\';
  214. end; {SlashedDirectory}
  215.  
  216. function PrinterStatus:byte;
  217. {Credits: Robert W. Lewis, VA thanks! Special masking employed for non-
  218.           standard printers, e.g. daisy wheels!!! }
  219. var Recpack : registers;
  220. begin
  221.    with Recpack do
  222.    begin
  223.       Ah := 2;
  224.       Dx := LPTport;
  225.       intr($17,recpack);
  226.       if (Ah and $B8) = $90 then
  227.          PrinterStatus := 0        {all's well}
  228.       else if (Ah and $20) = $20 then
  229.          PrinterStatus := 1        {no Paper}
  230.       else if (Ah and $10) = $00 then
  231.          PrinterStatus := 2        {off line}
  232.       else if (Ah and $80) = $00 then
  233.          PrinterStatus := 3        {busy}
  234.       else if (Ah and $08) = $08 then
  235.          PrinterStatus := 4;       {undetermined error}
  236.    end;
  237. end; {PrinterStatus}
  238.  
  239. function AlternatePrinterStatus:byte;
  240. var Recpack : registers;
  241. begin
  242.    with recpack do
  243.    begin
  244.       Ah := 2;
  245.       Dx := LPTport;
  246.       intr($17,recpack);
  247.       if (Ah and $20) = $20 then
  248.             AlternatePrinterStatus := 1  {no Paper}
  249.       else if (Ah and $10) = $00 then
  250.             AlternatePrinterStatus := 2  {off line}
  251.       else if (Ah and $80) = $00 then
  252.             AlternatePrinterStatus := 3  {busy}
  253.       else if (Ah and $08) = $08 then
  254.             AlternatePrinterStatus := 4  {undetermined error}
  255.       else
  256.           AlternatePrinterStatus := 0    {all's well}
  257.    end;
  258. end; {AlternatePrinterStatus}
  259.  
  260. function PrinterReady :boolean;
  261. begin
  262.     PrinterReady := (PrinterStatus = 0);
  263. end; {PrinterReady}
  264.  
  265. procedure ResetPrinter; {1.1}
  266. var
  267.   address: ^integer;
  268.   portno,delay : integer;
  269. begin
  270. {$IFDEF DPMI}
  271.    address := ptr(seg0040,$0008);
  272. {$ELSE}
  273.    address := ptr($0040,$0008);
  274. {$ENDIF}
  275.    portno := address^ + 2;
  276.    port[portno] := 232;
  277.    for delay := 1 to 2000 do {nothing};
  278.    port[portno] := 236;
  279. end; {ResetPrinter}
  280.  
  281. function CurrentTime: string;
  282. var
  283.   hour,min,sec:     string[2];
  284.   H,M,S,T : word;
  285. begin
  286.   GetTime(H,M,S,T);
  287.   Str(H,Hour);
  288.   Str(M,Min);
  289.   Str(S,Sec);
  290.   if S < 10 then        {pad a leading zero if sec is < 10 }
  291.      sec := '0'+sec;
  292.   if M < 10 then        {pad a leading zero if min is < 10 }
  293.      min := '0'+min;
  294.   if H > 12 then        { assign an a.m. or p.m. string }
  295.   begin
  296.      str(H - 12,hour);
  297.      if length(hour) = 1 then Hour := ' '+hour;
  298.      CurrentTime := hour+':'+min+':'+sec+' p.m.'
  299.   end
  300.   else if H < 1 then
  301.      CurrentTime := '12'+':'+min+':'+sec+' a.m.'
  302.   else
  303.      CurrentTime := hour+':'+min+':'+sec+' a.m.';
  304. end; {CurrentTime}
  305.  
  306. procedure PrintScreen;
  307. var Regpack : registers;
  308. begin
  309.    intr($05,regpack);
  310. end; {PrintScreen}
  311.  
  312. procedure Beep;
  313. begin
  314.     sound(800);Delay(